home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1993…ch: Other People's Memory / ADC Developer CD (1993-03) (''Other People's Memory'')_iso / Dev.CD Mar 93.iso / Development Platforms / LISP Related / LISP Goodies / McCartney-library 1.1 / CODE / misc / graphics-tools.lisp next >
Encoding:
Text File  |  1992-09-02  |  5.3 KB  |  163 lines  |  [TEXT/CCL2]
  1. ;;; graphics-tools.lisp
  2. ;;;
  3. ;;; Paul McCartney, Spring 1992
  4. ;;;
  5. ;;; Copyright © 1992 Paul McCartney.  All Rights Reserved.
  6. ;;; 
  7. ;;; Washington University Medical Informatics Training Program
  8. ;;;
  9. ;;; DESCRIPTION:
  10. ;;;
  11. ;;;
  12. ;;; USE:
  13. ;;;
  14. ;;;
  15. ;;; HISTORY:
  16. ;;;
  17. ;;;
  18.  
  19. (in-package :ccl)
  20.  
  21. (require :quickdraw)
  22.  
  23. (eval-when (:compile-toplevel :load-toplevel :execute)
  24.   (export '(find-pixel-increment-h find-pixel-increment-v change-brightness
  25.             point-value-in-range value-in-range draw-diamond
  26.             draw-up-arrow draw-down-arrow)
  27.           :ccl))
  28.  
  29.  
  30. (defun find-pixel-increment-h (scale inches power-of)
  31.   (let* ((n (* inches (/ *pixels-per-inch-x* scale)))
  32.          (power (ceiling (log n power-of))))
  33.     (expt power-of power)))
  34.  
  35.  
  36. (defun find-pixel-increment-v (scale inches power-of)
  37.   (let* ((n (* inches (/ *pixels-per-inch-y* scale)))
  38.          (power (ceiling (log n power-of))))
  39.     (expt power-of power)))
  40.  
  41.  
  42. (defun change-brightness (orig fraction)
  43.   (make-color (round (color-red orig) fraction)
  44.               (round (color-green orig) fraction)
  45.               (round (color-blue orig) fraction)))
  46.  
  47.  
  48. (defun point-value-in-range (value)
  49.   (min (max -32768 value) 32767))
  50.  
  51.  
  52. (defun value-in-range (min-value value max-value)
  53.   (min (max min-value value) max-value))
  54.  
  55.  
  56. ;;; Return the height, in pixels, of a font.  This is taken from the 
  57. ;;; Macintosh Common Lisp 2.0 Reference, page 55.
  58. ;;;
  59. (defun line-height (font-spec)
  60.   (multiple-value-bind (ascent descent widmax leading) 
  61.                        (font-info font-spec)
  62.     (declare (ignore widmax))
  63.     (+ ascent descent leading)))
  64.  
  65.  
  66. (defun make-polygon-shape (view &rest points)
  67.   (start-polygon view)
  68.   (move-to view (first points))
  69.   (dolist (point (rest points))
  70.     (line-to view point))
  71.   (get-polygon view))
  72.  
  73.  
  74. (defmethod draw-up-arrow ((view simple-view) topleft bottomright color &optional (outline-color color))
  75.   (let* ((size (subtract-points bottomright topleft))
  76.          (width (point-h size))
  77.          (height (point-v size))
  78.          (tip (add-points topleft (make-point (round width 2) 0)))
  79.          (head-y (round (* height 0.45)))
  80.          (left-point (add-points topleft (make-point 0 head-y)))
  81.          (right-point (add-points topleft (make-point width head-y)))
  82.          (left-center-point (add-points topleft (make-point (round (* width 2/5)) head-y)))
  83.          (right-center-point (add-points topleft (make-point (round (* width 3/5)) head-y)))
  84.          (left-bottom-point (add-points topleft (make-point (round (* width 2/5)) height)))
  85.          (right-bottom-point (add-points topleft (make-point (round (* width 3/5)) height)))
  86.          poly)
  87.     (start-polygon view)
  88.     (move-to view tip)
  89.     (line-to view right-point)
  90.     (line-to view right-center-point)
  91.     (line-to view right-bottom-point)
  92.     (line-to view left-bottom-point)
  93.     (line-to view left-center-point)
  94.     (line-to view left-point)
  95.     (line-to view tip)
  96.     (setf poly (get-polygon view))
  97.     (with-focused-view view
  98.       (with-fore-color color 
  99.         (paint-polygon view poly))
  100.       (with-fore-color outline-color 
  101.         (frame-polygon view poly))  )
  102.     (kill-polygon poly)
  103. ))
  104.  
  105.  
  106. (defmethod draw-down-arrow ((view simple-view) topleft bottomright color &optional (outline-color color))
  107.   (let* ((size (subtract-points bottomright topleft))
  108.          (width (point-h size))
  109.          (height (point-v size))
  110.          (tip (add-points topleft (make-point (round width 2) height)))
  111.          (head-y (round (* height 0.55)))
  112.          (left-point (add-points topleft (make-point 0 head-y)))
  113.          (right-point (add-points topleft (make-point width head-y)))
  114.          (left-center-point (add-points topleft (make-point (round (* width 2/5)) head-y)))
  115.          (right-center-point (add-points topleft (make-point (round (* width 3/5)) head-y)))
  116.          (left-bottom-point (add-points topleft (make-point (round (* width 2/5)) 0)))
  117.          (right-bottom-point (add-points topleft (make-point (round (* width 3/5)) 0)))
  118.          poly)
  119.     (start-polygon view)
  120.     (move-to view tip)
  121.     (line-to view right-point)
  122.     (line-to view right-center-point)
  123.     (line-to view right-bottom-point)
  124.     (line-to view left-bottom-point)
  125.     (line-to view left-center-point)
  126.     (line-to view left-point)
  127.     (line-to view tip)
  128.     (setf poly (get-polygon view))
  129.     (with-focused-view view
  130.       (with-fore-color color 
  131.         (paint-polygon view poly))
  132.       (with-fore-color outline-color 
  133.         (frame-polygon view poly))  )
  134.     (kill-polygon poly)
  135. ))
  136.  
  137.  
  138. (defmethod draw-diamond ((view simple-view) topleft bottomright color &optional (outline-color color))
  139.   (let* ((size (subtract-points bottomright topleft))
  140.          (width (point-h size))
  141.          (height (point-v size))
  142.          (top (add-points topleft (make-point (round width 2) 0)))
  143.          (bottom (add-points topleft (make-point (round width 2) height)))
  144.          (left (add-points topleft (make-point 0 (round height 2))))
  145.          (right (add-points topleft (make-point width (round height 2))))
  146.          poly)
  147.     (start-polygon view)
  148.     (move-to view top)
  149.     (line-to view right)
  150.     (line-to view bottom)
  151.     (line-to view left)
  152.     (line-to view top)
  153.     (setf poly (get-polygon view))
  154.     (with-focused-view view
  155.       (with-fore-color color
  156.         (paint-polygon view poly))
  157.       (with-fore-color outline-color
  158.         (frame-polygon view poly)) )
  159.     (kill-polygon poly)
  160. ))
  161.  
  162.  
  163. (provide :graphics-tools)